perm filename MATE.SAI[1,BGB] blob
sn#130781 filedate 1974-11-15 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00009 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 BEGIN "TEST"
C00004 00003 SUBR MKVERTICES
C00006 00004 SUBR ECROSS(ITG I,J)
C00008 00005 RECURSIVE PROCEDURE QSORT (INTEGER I,J REAL CUT)
C00009 00006 SUBR MATEVV (INTEGER V1,V2)
C00010 00007 SUBR MKEDGES
C00012 00008 SUBR EECROSS
C00013 00009 α MAIN EXECUTION
C00014 ENDMK
C⊗;
BEGIN "TEST"
REQUIRE "ABBREV[SYS,BGB]" SOURCE_FILE;
REQUIRE "DPYIII[SYS,BGB]" SOURCE_FILE;
SAFE ITG ARRAY DPYBUF[0:3000];
α VERTEX "NODES";
SAFE REAL ARRAY X,Y,Z[1:100];
SAFE ITG ARRAY VX,VY,PED[1:100];
α EDGE "NODES";
SAFE ITG ARRAY PVT,NVT,EDG[0:1000];
SAFE REAL ARRAY AA,BB,CC,DD[1:1000];
ITG I,J,K,RRMAX,RMAX;
ITG VCNT,ECNT,FCNT;
ITG COMCNT,EECNT;
α MICRO LISP;
SAFE ITG ARRAY FS[1:4000];ITG FSPTR;
ITG SUBR XWD(ITG A,B); S⊂ HRLZ 1,A;HRR 1,B;⊃;
ITG SUBR CONS(ITG A,B); ⊂ ITG I;I←FSPTR;
FSPTR←FS[I];FS[I]←XWD(A,B);RETURN(I);⊃;
DEFINE CAR(A)="(FS[A] LSH -18)";
DEFINE CDR(A)="(FS[A] LAND '777777)";
SUBR MKVERTICES;
BEGIN "MKVERTICES"
FOR I←1 THRU VCNT DO
BEGIN "MKV"
X[1]←X[4]←Y[1]←Y[2]← -500;
X[2]←X[3]←Y[3]←Y[4]← +500;
FOR I←1 THRU 4 DO
BEGIN
AIVECT(X[I]-6,Y[I]-6);
DPYSST("* "&CVS(I));
END;
FOR I←5 THRU VCNT DO
BEGIN
X[I] ← RAN(0)*1000 - 500;
Y[I] ← RAN(0)*1000 - 500;
AIVECT(X[I]-6,Y[I]-6);
DPYSST("* "&CVS(I));
END;
END "MKV";
END "MKVERTICES";
SUBR ECOEF (ITG E);
BEGIN "ECOEF"
ITG V1,V2,A,B; REAL C,D;
V1 ← PVT[E];
V2 ← NVT[E];
A ← Y[V1]-Y[V2];
B ← X[V2]-X[V1];
C ← X[V1]*Y[V2] - X[V2]*Y[V1];
D ← SQRT(A*A + B*B);
AA[E] ← A/D;
BB[E] ← B/D;
CC[E] ← C/D;
DD[E] ← D;;
END "ECOEF";
SUBR ECROSS(ITG I,J);
BEGIN "ECROSS"
ITG V1,V2,U1,U2;
REAL D1,D2;
α EPSILON;
DEFINE PE="0.0001";
DEFINE NE="-0.0001";
IF PVT[I]=0 ∨ PVT[J]=0 THEN RETURN;
α TEST FOR FOUR DISTINCT VERTICES;
V1 ← PVT[I]; V2 ← NVT[I];
U1 ← PVT[J]; U2 ← NVT[J];
IF V1=U1 ∨ V1=U2 ∨ V2=U1 ∨ V2=U2 THEN RETURN;
α COMPARE COUNTER;
COMCNT←COMCNT+1;
α TEST FOR SPAN OVERLAP;
IF (X[U1] MAX X[U2]) < (X[V1] MIN X[V2]) THEN RETURN;
IF (Y[U1] MAX Y[U2]) < (Y[V1] MIN Y[V2]) THEN RETURN;
IF (X[V1] MAX X[V2]) < (X[U1] MIN X[U2]) THEN RETURN;
IF (Y[V1] MAX Y[V2]) < (Y[U1] MIN Y[U2]) THEN RETURN;
α TEST FOR HALF PLANE CROSSING;
D1 ← AA[I]*X[U1] + BB[I]*Y[U1] + CC[I];
D2 ← AA[I]*X[U2] + BB[I]*Y[U2] + CC[I];
IF (D1≥PE ∧ D2≥PE) ∨ (D1≤NE ∧ D2≤NE) THEN RETURN;
α TEST FOR HALF PLANE CROSSING;
D1 ← AA[J]*X[V1] + BB[J]*Y[V1] + CC[J];
D2 ← AA[J]*X[V2] + BB[J]*Y[V2] + CC[J];
IF (D1≥PE ∧ D2≥PE) ∨ (D1≤NE ∧ D2≤NE) THEN RETURN;
α DELETE LONGER EDGE;
IF DD[J] > DD[I] THEN I↔J;
PVT[I]←NVT[I]←0;
END "ECROSS";
RECURSIVE PROCEDURE QSORT (INTEGER I,J; REAL CUT);
BEGIN "QSORT"
INTEGER L,H;
α BUBBLE SORT THE FEW;
IF (J-I) ≤ 6 THEN ⊂
FOR L←I THRU J-1 DO FOR H←L+1 THRU J DO
IF DD[EDG[L]] < DD[EDG[H]] THEN EDG[L]↔EDG[H]; RETURN;⊃;
α PARTITION SORT THE MANY;
L ← I; H ← J;
WHILE TRUE DO
BEGIN
WHILE L<H ∧ DD[EDG[L]] ≥ CUT DO L←L+1;
WHILE L<H ∧ DD[EDG[H]] < CUT DO H←H-1;
IF L=H THEN ⊂ L←L-1;DONE;⊃;
EDG[L]↔EDG[H];
END;
IF I<L THEN QSORT(I,L, (DD[EDG[I]] + DD[EDG[L]])/2);
IF H<J THEN QSORT(H,J, (DD[EDG[H]] + DD[EDG[J]])/2);
END "QSORT";
SUBR MATEVV (INTEGER V1,V2);
BEGIN "MATEVV"
ITG I,EL,E;
IF (X[V1]-X[V2])↑2 + (Y[V1]-Y[V2])↑2 > RRMAX THEN RETURN;
IF V2>V1 THEN V1↔V2;
EL ← PED[V1];
WHILE EL≠0 DO ⊂ E←CAR(EL);
IF V1=PVT[E] ∧ V2=NVT[E] THEN RETURN ELSE EL←CDR(EL);⊃;
ECNT ← ECNT+1;
PVT[ECNT] ← V1;
NVT[ECNT] ← V2;
PED[V1] ← CONS(ECNT,PED[V1]);
PED[V2] ← CONS(ECNT,PED[V2]);
END "MATEVV";
SUBR MKEDGES;
BEGIN "MKEDGES"
ECNT ← 0;
RRMAX ← RMAX*RMAX;
α XSORT THE VERTICES;
FOR I←1 THRU VCNT DO EDG[I]←I;
ARRBLT(DD[1],X[1],VCNT);
QSORT(1,VCNT,(X[1]+X[VCNT])/2);
ARRBLT(VX[1],EDG[1],VCNT);
α YSORT THE VERTICES;
FOR I←1 THRU VCNT DO EDG[I]←I;
ARRBLT(DD[1],Y[1],VCNT);
QSORT(1,VCNT,(Y[1]+Y[VCNT])/2);
ARRBLT(VY[1],EDG[1],VCNT);
FOR I←1 THRU VCNT-1 DO
FOR J←I+1 THRU VCNT DO
IF VX[J] - VX[I] < RMAX THEN
MATEVV(VX[I],VX[J]) ELSE DONE;
FOR I←1 THRU VCNT-1 DO
FOR J←I+1 THRU VCNT DO
IF VY[J] - VY[I] < RMAX THEN
MATEVV(VY[I],VY[J]) ELSE DONE;
FOR K←1 THRU ECNT DO ECOEF(K);
END "MKEDGES";
SUBR EECROSS;
BEGIN "EECROSS"
ITG V1,V2,E1,E2,E3,EL1,EL2,EL3;
FOR V1←1 THRU VCNT DO
BEGIN "V1"
EL1 ← PED[V1];
WHILE EL1≠0 DO
BEGIN "EL1"
E1←CAR(EL1);
EL1←CDR(EL1);
IF (V2←PVT[E1])=0 THEN CONTINUE
ELSE IF V1=V2 THEN V2←NVT[E1];
EL3 ← PED[V1];
WHILE EL3≠0 DO
BEGIN "EL3"
E3←CAR(EL3);
EL3←CDR(EL3);
EL2 ← PED[V2];
WHILE EL2≠0 DO
⊂ E2←CAR(EL2);
EL2←CDR(EL2);
IF E2<E3 THEN ECROSS(E2,E3);⊃;
END "EL3";
END "EL1";
END "V1";
END "EECROSS";
α MAIN EXECUTION;
RAN(37);
WHILE TRUE DO
BEGIN "FOREVER"
RMAX ← 4000;
VCNT ← 15;
ECNT ← 0;
ARRCLR(PVT);ARRCLR(NVT);ARRCLR(EDG);
ARRCLR(VX);ARRCLR(VY);ARRCLR(PED);
ARRCLR(FS);
FOR I←1 THRU 3999 DO FS[I]←I+1;
FS[4000]←0;
FSPTR←1;
DPYSET(DPYBUF);
DPYBIG(1);
MKVERTICES;
MKEDGES;
EECROSS;
FOR K←1 THRU ECNT DO
IF PVT[K]≠0 THEN
⊂ AIVECT(X[PVT[K]],Y[PVT[K]]);
AVECT(X[NVT[K]],Y[NVT[K]]);⊃;
DPYOUT(1);
INCHRW;
END "FOREVER"
END "TEST";